Shareware Grab Bag/Shareware Grab Bag.iso/090/td.arc/TD2.PAS

Pascal/Delphi Source File | 1985-07-03 | 17.9 KB | 742 lines

program td;   { version 2.12  Copright (c) 1985 by Mark Johnson 05/28/85 }

   { This program is protected under Copyright law.  It has been placed }
   { in the public domain for personal non-commercial use only.  You    }
   { may use this code, modify it, or give it away.  The author has     }
   { relinquished personal gain from this program and so should you.    }
   { This program was originally sold as a DEMO version.  The only      }
   { documentation available is in the code.  If you are interested in  }
   { more powerful versions for Pascal, COBOL, BASIC, PL/I, NEAT/3, or  }
   { 8086 Assembler, Please contact the author.                         }
   { This program is available written in NCR-COBOL, NCR ITX-Pascal and }
   { IBM-PL/I for direct use on mainframes and minis.                   }

   { This program was originally written in PL/I to generate PL/I code, }
   { then run through a PL/I to Pascal translator.  The output of the   }
   { translator was cleaned up by hand.  Some months later when Turbo   }
   { Pascal was released, a new version of this program was produced to }
   { generate Pascal code.                                              }

   { Mark E. Johnson                 2272-F Benson Avenue               }
   {                                 St. Paul Minnesota  55116          }
   { evening phone                   612-698-3686                       }

const
  debug = false;

type
  ltype = string[85];
  stype = string[10];

var   { this could have been a RECORD, but the PL/I to Pascal translator }
      { is a bit stupid.                                                 }

    rtype     : array[1..64] of integer;
    rname     : array[1..64] of ltype;
    rx        : array[1..64] of integer;
    ry        : array[1..64] of integer;
    rlen      : array[1..64] of integer;
    rscale    : array[1..64] of integer;
    rorder    : array[1..64] of integer;


    ndx       : integer;
    line      : ltype;
    lineno    : integer;
    colno     : integer;
    token     : ltype;
    tail      : string[32];
    i,j,l     : integer;
    incr      : integer;
    outtype   : char;
    ans       : char;
    infile    : text;
    outfile   : text;
    libfile   : text;
    procname  : string[32];
    varfl     : boolean;
    librfl    : boolean;
    subrfl    : boolean;
    ctemp     : stype;
    efile     : boolean;
    level     : integer;
    inname    : string[15];
    outname   : string[15];
    libname   : string[15];

label
    generate, retry, endinp;

function toupper(mess : ltype) : ltype;
var
  temp : ltype;
  i    : integer;

begin
  temp:='';
  for i:=1 to length(mess) do
    temp:=concat(temp,upcase(copy(mess,i,1)));
  toupper:=temp;
end;

procedure space(n : integer);
var
  i  : integer;

begin
    writeln;
    for i:=1 to n do
      write(' ');
end;

procedure enter(mess : ltype);   { ENTER and LEAVE are debugging routines }
begin                            { no longer used in this program.        }
  if debug = true then
    begin
    level:=level+1;
    space(level);
    write(' Entering - ',mess);
  end;
end;

procedure leave(mess : ltype);
begin
  if debug = true then
    begin
    level:=level-1;
    space(level);
    write(' Leaving - ',mess)
  end;
end;

function convert(num : integer) : stype;

var
  st1  : stype;

begin
  str(num,st1);
  while copy(st1,1,1) = ' ' do
    st1:=copy(st1,2,length(st1)-1);
  convert:=st1;
end;

function rev(f : boolean) : boolean;   { tacky }
begin
  if f = true
    then rev:=false
  else
    rev:=true;
end;

procedure setup;
var
  ans    : char;
  iotype : string[8];
  ftype  : char;

begin
  for i:=1 to ndx-1 do
    begin
    if rtype[i] > 0 then
      begin
      clrscr;
      iotype:='Out Alfa 1';
      if rtype[i] = 2 then
        iotype:='In Alfa 2'
      else if rtype[i] = 3 then
        iotype:='In Num 3';

      gotoxy(23,2);
      write('Variable Definitions');
      gotoxy(20,5);
      write('NAME   - ');
      lowvideo;
      write(rname[i]);
      highvideo;
      gotoxy(20,7);
      write('TYPE   - ');
      lowvideo;
      write(iotype);
      highvideo;
      gotoxy(20,8);
      write('LENGTH - ');
      lowvideo;
      write(rlen[i]);
      highvideo;
      gotoxy(20,10);
      write('SCALE  - ');
      lowvideo;
      write(rscale[i]);
      highvideo;
      gotoxy(10,20);
      write('Change or add to this record?    ');
      gotoxy(1,21);
      read(kbd,ans);
      if (ans='y') or (ans='Y') then
        begin
        if rtype[i]=2 then
          begin
          gotoxy(10,20);
          write('N)umeric or A)lpha (N or A)     ');
          gotoxy(40,7);
          read(kbd,ans);
          if (ans='n') or (ans='N') then
            rtype[i]:=3;
        end;
        gotoxy(10,20);
        write('Enter length ( 1 - 80 )         ');
        gotoxy(40,8);
        readln(rlen[i]);
        if (rtype[i]=3) or (rtype[i]=1) then
          begin
          gotoxy(10,20);
          write('Enter Scale (0 - 15)         ');
          gotoxy(40,10);
          readln(rscale[i]);
        end;
        { i:=i-1; }
      end;
    end;
  end;
end;

function getvar(line : ltype) : ltype;
var
  k     : integer;

begin
  incr:=0;
  if (copy(line,1,1)='!') or (copy(line,1,1)='#') then
    begin
    k:=pos(' ',line);
    if k = 0 then
      getvar:=line
    else
      begin
      incr:=k-1;
      getvar:=(copy(line,1,k-1))
    end;
  end
  else
    begin
    k:=pos('!',line);
    if k=0 then
      k:=pos('#',line);
    if k=0 then
      getvar:=line
    else
      begin
      incr:=k-1;
      getvar:=copy(line,1,k-1);
    end;
  end;
end;

function deblank(str1 : stype) : stype;
var
  str2      : stype;
  c         : char;
  i         : integer;

label 99;

begin
  enter('Function deblank');
  str2:=str1;
  if (copy(str2,1,1)='!') or (copy(str2,1,1)='#') then
    str2:=copy(str2,2,(length(str2)-1)+1);
  for i:=length(str2) downto 1 do
    begin
    if copy(str2,i,1) <> ' ' then
      goto 99;
  end;
99:
  deblank:=copy(str2,1,i);
end;

function verify(st2 : ltype) : integer;  { return pos of 1st non-space }
var
  i    : integer;
label gotit;

begin
  for i:=1 to length(st2) do
   if copy(st2,i,1) <> ' ' then
     goto gotit;

gotit:
  if i=length(st2) then  { all spaces }
    verify:=0
  else
    verify:=i;
end;


Procedure menu;
var
  continue : boolean;

Begin

  Clrscr;
  Gotoxy(11,1);
  Write('Copyright (c) 1985  Mark E.Johnson - MicroTools Co.');
  Gotoxy(1,2);
  Write(' ');
  Gotoxy(25,6);
  Write('TurboDraw 2.0');
  Gotoxy(27,7);
  Write('File Menu');
  continue:=true;
  while continue = true do
    begin
    Gotoxy(16,9);
    Write('1). Screen Input File   ');
    lowvideo;
    Gotoxy(40,9);
    Write(inname);
    highvideo;
    Gotoxy(16,10);
    Write('2). Pascal Output File  ');
    lowvideo;
    Gotoxy(40,10);
    Write(outname);
    highvideo;
    Gotoxy(16,11);
    Write('3). Library Input File  ');
    lowvideo;
    Gotoxy(40,11);
    Write(libname);
    highvideo;
    gotoxy(16,12);
    write('4). Exit to main menu ');
    Gotoxy(16,14);
    Write('Enter Option 1,2,3, or 4  ');
    Gotoxy(42,14);
    read(kbd,ans);
    if ans='4' then
      continue:=false
    else
      begin
      Gotoxy(16,14);
      Write('Enter File name or <C/R>   ')
    end;
    if ans='1' then
      begin
      lowvideo;
      gotoxy(40,9);
      write('               ');
      gotoxy(40,9);
      readln(inname);
      highvideo;
      inname:=toupper(inname);
    end
    else if ans='2' then
      begin
      lowvideo;
      gotoxy(40,10);
      write('               ');
      gotoxy(40,10);
      readln(outname);
      highvideo;
      outname:=toupper(outname)
    end
    else if ans='3' then
      begin
      lowvideo;
      gotoxy(40,11);
      write('               ');
      gotoxy(40,11);
      readln(libname);
      highvideo;
      libname:=toupper(libname)
    end;
  end;
End;

procedure wrname(i : integer);
var
  x : integer;
begin
  for x:=1 to 20 do
    if x <= length(rname[i]) then
      write(copy(rname[i],x,1));
end;

procedure sort;
var
    htype     : integer;
    hname     : ltype;
    hx        : integer;
    hy        : integer;
    hlen      : integer;
    hscale    : integer;
    horder    : integer;

    litvar,iotype,ftype : stype;
    junk      : char;
    ord1,ord2 : integer;
    i,j       : integer;
    again,l1  : boolean;

label ordl,endsort;

begin
    while true do
        begin
        clrscr;
        lowvideo;
        write('Order Field Name               Literal/Variable  Input/Output  Alpha/Numeric');
        highvideo;

        j:=1;
        for i:=1 to ndx-1 do
            begin
            if j > 18 then
                begin
                j:=1;
                gotoxy(1,22);
                write('Press a key to continue ');
                read(kbd,junk);
                clrscr;
                lowvideo;
                writeln('Order Field Name               Literal/Variable  Input/Output  Alpha/Numeric');
                highvideo;

            end;
            litvar:='Variable';
            iotype:='Output';
            ftype:='Alpha';
            if rtype[i]=0 then
                litvar:='Literal'
            else if rtype[i]=2 then
                iotype:='Input'
            else if rtype[i]=3 then
                begin
                iotype:='Input';
                ftype:='Numeric'
            end;
            if rname[i] <> '' then
                begin
                gotoxy(1,j+1);
                write(rorder[i]:3);
                gotoxy(7,j+1);
                wrname(i);
                gotoxy(32,j+1);
                write(litvar);
                gotoxy(50,j+1);
                write(iotype);
                gotoxy(64,j+1);
                write(ftype);
                j:=j+1;
            end;
        end;
        L1:=TRUE;
        repeat
            gotoxy(1,22);
            write('Enter field to change, or 999 to quit    ');
            lowvideo;
            gotoxy(1,23);
            write('      ');
            gotoxy(1,23);
            readln(ord1);
            highvideo;
            if ord1=999 then
                goto endsort;
            for j:=1 to ndx-1 do
                if ord1=rorder[j] then
                    goto ordl;
 ordl:      if ord1 = rorder[j] then
                l1:=FALSE;
        until l1 = false;
        ord1:=j;
        gotoxy(1,22);
        write('Place at field #                        ');
        lowvideo;
        gotoxy(1,23);
        write('     ');
        gotoxy(1,23);
        readln(ord2);
        highvideo;
        rorder[ord1]:=ord2;

 { Simple bubble sort is fast enough for this application }

        Again:=TRUE;
        while again = true do
            begin
            Again:=FALSE;
            for i:=1 to ndx-2 do
                begin
                If rorder[i] > rorder[i+1] Then
                    begin
                    hname:=rname[i];
                    htype:=rtype[i];
                    hx:=rx[i];
                    hy:=ry[i];
                    hlen:=rlen[i];
                    hscale:=rscale[i];
                    horder:=rorder[i];
                    rname[i]:=rname[i+1];
                    rtype[i]:=rtype[i+1];
                    rx[i]:=rx[i+1];
                    ry[i]:=ry[i+1];
                    rlen[i]:=rlen[i+1];
                    rscale[i]:=rlen[i+1];
                    rorder[i]:=rorder[i+1];
                    rname[i+1]:=hname;
                    rtype[i+1]:=htype;
                    rx[i+1]:=hx;
                    ry[i+1]:=hy;
                    rlen[i+1]:=hlen;
                    rscale[i+1]:=hscale;
                    rorder[i+1]:=horder;
                    again:=TRUE;
                end;  { if rorder[i] }
            end;      { for i:=1 to  }
        end;          { while again  }
     end;
    endsort:
 End;


begin { main }
  inname:='DEMO.SCR';
  outname:='DEMO.PAS ';
  libname:='TD.LIB';
retry:
  menu;
  level:=0;
  varfl:=true;
  librfl:=false;
  subrfl:=false;
  outtype:='C';
  ndx:=1;
  lineno:=1;
  assign(infile,inname);
  {$I-}
  reset(infile);
  {$I+}
  if ioresult <> 0 then
    begin
    writeln;
    writeln('Screen file not found, Press a key to continue ');
    read(kbd,ans);
    goto retry
  end;
  if librfl=true then
    begin
    assign(libfile,'TD.LIB');
    {$I-}
    reset(libfile);
    {$I+}
    if ioresult <> 0 then
      begin
      writeln('LIB file not found, Press a key to continue ');
      read(kbd,ans);
      close(infile);
      goto retry
    end;
  end;

  assign(outfile,outname);
  rewrite(outfile);

  efile:=false;
  while efile = false do
    begin
    colno:=1;
    readln(infile,line);
    if eof(infile) then
      efile:=true;
    l:=length(line);
    i:=0;
    while colno < l do
      begin
      i:=verify(line);
      if (i=0) and (length(line) > 0) then
        i:=1;
      if i > 0 then
        begin
        colno:=colno+i+incr-1;
        token:=GETVAR(copy(line,i,(length(line)-i)+1));
        j:=i+length(token);
        rtype[ndx]:=0;
        if copy(token,1,1) = '!' then
          begin
          rtype[ndx]:=1;
          token:=copy(token,2,length(token)-1);
        end
        else if copy(token,1,1) = '#' then
          begin
          rtype[ndx]:=2;
          token:=copy(token,2,length(token)-1);
        end;
        rname[ndx]:= token;  {deblank(token);}
        rx[ndx]:=lineno;
        ry[ndx]:=colno;
        rlen[ndx]:=0;
        rscale[ndx]:=0;
        rorder[ndx]:=ndx*10;
        if j >= length(line) then
          l:=0
        else
          line:=copy(line,j,(length(line)-j)+1);
        ndx:=ndx+1;
      end;
    end;
    lineno:=lineno+1;
  end;

endinp:
  close(infile);
  while true do
    begin
    clrscr;
    gotoxy(28,3);
    write('TurboDraw');
    gotoxy(28,6);
    write('OPTIONS');
    lowvideo;
    gotoxy(19,10);
    write('G - Generate code and exit');
    gotoxy(19,11);
    write('V - Variable declarations');
    gotoxy(19,12);
    write('O - Order of input/output');
    gotoxy(19,13);
    write('L - Include Library functions');
    highvideo;
    gotoxy(50,13);
    if librfl = true then
      write('Yes')
    else
      write(' No');
    lowvideo;
    gotoxy(19,14);
    write('P - Generate a procedure');
    highvideo;
    gotoxy(50,14);
    if subrfl = true then write('Yes')
      else write(' No');
    lowvideo;
    gotoxy(19,15);
    write('I - Include VAR Definitions');
    highvideo;
    gotoxy(50,15);
    if varfl = true then write('Yes')
      else write(' No');
    gotoxy(19,18);
    write('Enter Option: ');
    read(kbd,ans);
    case ans of
      'p','P'  :    begin
                      subrfl:=rev(subrfl);
                      if subrfl=true then
                        begin
                        gotoxy(19,22);
                        lowvideo;
                        write('Enter name of procedure ');
                        highvideo;
                        readln(procname)
                      end
                    end;

       'l','L'  :  librfl:=rev(librfl);
       'i','I'  :  varfl:=rev(varfl);
       'g','G'  :  goto Generate;
       'v','V'  :  Setup;
       'o','O'  :  sort;

  end;
end;

       { Generate Code for TURBO PASCAL }

generate:
writeln(outfile);
writeln(outfile,'{ Start of Turbodraw code }');
  if varfl = true then
    begin
    writeln(outfile,'Var');
    for i:=1 to ndx-1 do
      begin
      if rtype[i] > 0 then
        begin
        writeln(outfile);
        write(outfile,'  ',rname[i]);
        if rtype[i] = 1 then
          write(outfile,' : Integer;')
        else if rtype[i] = 2 then
          write(outfile,' : String[',convert(rlen[i]),'];')
        else
          begin
          if rscale[i] > 0 then
            write(outfile,' : Real;')
          else
            write(outfile,' : Integer;');
        end;
      end;
    end;
    writeln(outfile);
  end;
  writeln(outfile);
  if librfl = true then
    begin
    assign(libfile,libname);
    reset(libfile);
    while not eof(libfile) do     { Include library code }
      begin
      readln(libfile,line);
      writeln(outfile,line);
    end;
  close(libfile)
  end;
  if subrfl = true then
    begin
    writeln(outfile);
    writeln(outfile,'Procedure ',procname,';');
    writeln(outfile,'Begin');
    writeln(outfile,'  Clrscr;');
  end;
  for i:=1 to ndx-1 do
    begin
    if rname[i] > ' ' then
      writeln(outfile,'  Gotoxy(',convert(ry[i]),',',convert(rx[i]),');');
    if rtype[i]=0 then
      begin
      if rname[i] > ' ' then
        writeln(outfile,'  Write(''',rname[i],''');');
    end
    else if rtype[i]=1 then
      begin
      tail:=convert(rlen[i]);
      tail:=concat(':',tail);
      if rscale[i] > 0 then
        tail:=concat(tail,':',convert(rscale[i]));
      tail:=concat(tail,');');
      if rlen[i] = 0 then
        writeln(outfile,'  Write(',rname[i],');')
      else
        writeln(outfile,'  Write(',rname[i],tail)
    end

    else if (rtype[i]=2) or (rtype[i]=3) then
      begin
      if rlen[i] = 0 then
        writeln(outfile,'  Readln(',rname[i],');')
      else
      if rscale[i] > 0 then
        writeln(outfile,'  ',rname[i],':=Getreal(',convert(rlen[i]),',',convert(rscale[i]),');')
      else
        writeln(outfile,'  ',rname[i],':=Getint(',convert(rlen[i]),');');
    end;
  end;
  if subrfl = true then
    writeln(outfile,'End;');
  writeln(outfile,'{ End of Turbodraw Code }');
  writeln(outfile);
  close(outfile);
end.